C     IODAT1    This file containing I/O subroutines for data files. 
C     Copyright (C) 1997  Filip Hroch, Masaryk University, Brno, CZ
C                    
C     This program is free software; you can redistribute it and/or modify
C     it under the terms of the GNU General Public License as published by
C     the Free Software Foundation; either version 2 of the License, or
C     (at your option) any later version.
C     
C     This program is distributed in the hope that it will be useful,
C     but WITHOUT ANY WARRANTY; without even the implied warranty of
C     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
C     GNU General Public License for more details.
C
C     You should have received a copy of the GNU General Public License  
C     along with this program; if not, write to the Free Software
C     Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
C
C    E-mail: hroch@physics.muni.cz
C    Web:    http://www.sci.muni.cz/~hroch/index.html
C    Postal address: F.Hroch
C                    Department of Theoretical Physics and Astrophysics
C                    Masaryk University
C                    Kotlarska 2
C                    611 37 Brno
C                    Czech Republic
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C Some fragments of this file are the DAOPHOT routines by P.B.Stetson.
C
C#######################################################################
C
C
      CHARACTER*250  FUNCTION  SWITCH  (FILE, ADDEND)
C
C=======================================================================
C
C Subroutine to chop off a filename extension from an input filename
C character string, and append a new character string to the end.
C
C Arguments
C
C   FILE (INPUT) is a character string containing a filename.
C
C ADDEND (INPUT) is the character string to be pasted onto the end
C        of the character string obtained by removing a directory
C        name and the period and all that follows from the input
C        filename.
C
C SWITCH is the filename part of NAFILE, with any directory name
C        contained in brackets chopped off from the front, and with
C        the character string ADDEND substituted for the period and
C        filename extension of the input string.
C
C=======================================================================
C
      IMPLICIT NONE
      INTEGER LEN
C
      CHARACTER*(*) FILE, ADDEND
      INTEGER I, L, LAST
      
      LAST = 0
      L = LEN(FILE)
      I=L+1
 1000 I=I-1
      IF (I .EQ. 0) GO TO 9000
      IF (FILE(I:I) .EQ. '.') THEN
         SWITCH=FILE(1:I-1)//ADDEND
         RETURN
      ELSE IF (FILE(I:I) .EQ. ' ') THEN
         GO TO 1000
      ELSE
         IF( LAST.EQ.0 ) LAST=I
         GO TO 1000
      END IF
C
 9000 CONTINUE
      SWITCH=FILE(1:LAST)//ADDEND
      RETURN
C
 9100 CONTINUE
      WRITE (6,691) CHAR(7), FILE, ADDEND
  691 FORMAT (/' Error creating file name: ', A1, 5X, A30, 5X, A10/)
      RETURN
      END!
C
C#######################################################################
C
      SUBROUTINE  RDSTAR (LU, NL, ID, X, Y, AMAG, SKY)
C
C=======================================================================
C
C Read in an ID number, x and y coordinates, magnitude, and sky value
C for the next star in the input file, whatever the file type (i.e.,
C NL = 1, 2, or 3).  If an end of file is encountered, set the star ID
C to a negative number and return; if a blank line is encountered, the
C star ID will be zero.  LU is the logical unit number to be used; the
C other arguments are obvious.
C
C=======================================================================
C
      IMPLICIT NONE
      CHARACTER*133 LINE
      DOUBLE PRECISION X, Y, AMAG, SKY, DUMMY
      INTEGER LU, N, ISTAT, ID, NL
C
  900 CALL RDCHAR (LU, LINE, N, ISTAT)
      IF (ISTAT .GT. 0) THEN
         ID = -1   !  ID = -1 means END OF FILE
         RETURN
      ELSE IF (ISTAT .LT. 0) THEN
         CALL STUPID ('Unable to read line from input file')
         RETURN
      END IF
C
      IF (N .LE. 1) THEN
         ID = 0                 ! Blank line
         RETURN
      END IF
C
      N = N+1
C      LINE(N:N) = '/'
      IF (NL .EQ. 0) THEN
         BACKSPACE(LU,ERR=1000) 
         READ (LU,*,ERR=1000) ID, X, Y        
      ELSE IF (NL .EQ. 1) THEN
         READ (LINE(2:N),700,ERR=1000) ID, X, Y, AMAG, DUMMY, SKY
      ELSE IF (NL .EQ. 2) THEN
         READ (LINE(2:N),700,ERR=1000,END=2000) ID, X, Y, AMAG
         IF (ID .NE. 0) READ(LU,'(F13.0)',ERR=1000) SKY
      ELSE IF (NL .EQ. 3) THEN
         READ (LINE(2:N),700,ERR=1000) ID, X, Y, AMAG, SKY
      END IF
      RETURN                                             ! Normal return
700   FORMAT(I6,14F9.3)   
 1000 CALL STUPID
     .     ('WARNING:  Corrupt star data encountered in input.')
      GO TO 900
C
C-----------------------------------------------------------------------
C
C End of file was encountered.
C
 2000 ID=-1
      RETURN
C
      END!
C
C#######################################################################
C
      SUBROUTINE  RDHEAD (LUN, NL, NCOL, NROW, LOBAD, HIBAD,
     .     THRESH, AP1, PHPADU, READNS, FRAD)
C
C=======================================================================
C
C Read file header from a sequential data file on the disk.  If the
C file has no header, rewind to beginning.
C
C Input argument
C
C    LUN  is the logical unit number of the disk file.
C
C     NL  if NL is greater than zero on input, then in the event that
C         the header is missing from the input file, the missing
C         header information will be requested via the keyboard.
C         If NL is equal to zero on input, only NCOL and NROW
C         will be requrested.  If NL is a negative number on input,
C         missing information will NOT be requested of the user.
C
C Output arguments
C
C     NL  is a code indicating the file type:
C            NL = 3 a group file
C            NL = 2 an aperture photometry file
C            NL = 1 other (output from FIND, PEAK, or NSTAR)
C            NL = 0 a file without a header
C
C    NCOL  is the number of columns in the picture (length in x)
C
C    NROW  is the number of rows in the picture (length in y)
C
C  THRESH  is the star-finding threshold that was used (from FIND)
C
C     AP1  is the radius of the first aperture (from PHOT)
C
C  PHPADU  is the number of photons per ADU that was given(from PHOT)
C
C  READNS  is the readout noise per pixel in ADU (from PHOT)
C
C   LOBAD  is the low bad pixel limit that was used (from FIND)
C
C   HIBAD  is the high bad pixel limit that was used (from FIND)
C
C    FRAD  is the fitting radius (from OPTION, used by PSF, PEAK,
C          and NSTAR)
C
C=======================================================================
C
      IMPLICIT NONE
      CHARACTER*133 LINE
      CHARACTER*4 FIRST4, TEST
      DOUBLE PRECISION 
     .    LOBAD, HIBAD, THRESH, AP1, PHPADU, READNS, FRAD, X
      INTEGER LUN, NL, NCOL, NROW, N, ISTAT, NLIN
C
      READ (LUN,900) FIRST4, TEST
  900 FORMAT (A4, 9X, A4)
      IF (FIRST4 .NE. ' NL ') GO TO 8000               ! No header lines
      IF (TEST .EQ. '  LO') THEN
C
C Latest DAOPHOT II file header.
C               
         CALL RDCHAR (LUN, LINE, N, ISTAT)
         N = N+1
C         LINE(N:N) = '/'
         READ (LINE,9001) NL, NCOL, NROW, LOBAD, HIBAD, THRESH,
     .        AP1, PHPADU, READNS, FRAD
 9001    FORMAT (1X, I2, 2I5, 7F8.1,/)
      ELSE IF ((TEST .NE. 'LOWB') .AND. (TEST .NE. 'OWBA')) THEN
C
C Obsolete file header.
C
C         READ (LUN,901) NLIN, NCOL, NROW, THRESH, AP1, PHPADU, READNS,
C     .        LOBAD, FRAD
C  901    FORMAT (1X, I2, 2I4, 7F8.1)
C         IF (NL .GE. 0) THEN
C            IF (AP1 .LE. 0.) THEN
C 1010          CALL GETDAT ('Lowest good data-value:', LOBAD, 1)
C               IF (LOBAD .LE. -1.E38) GO TO 1010
C            END IF
C 1020       CALL GETDAT ('Highest good data-value:', HIBAD, 1)
C            IF (HIBAD .LE. 0.) GO TO 1020
C         END IF
C         NL=NLIN
          PRINT *,' Missing file header. Return.'
          RETURN
      ELSE
         READ (LUN,901) NL, NCOL, NROW, LOBAD, HIBAD, THRESH, AP1,
     .        PHPADU, READNS, FRAD
      END IF
      READ (LUN,900)
      RETURN                                           ! Normal return
  901 FORMAT (1X, I2, 2I4, 7F8.1)

 8000 REWIND (LUN)
C      IF (NL .GE. 0) THEN
C 8001    CALL GETDAT ('Number of columns in the image:', X, 1)
C         IF (X .LT. 0.5) GO TO 8001
C         NCOL = NINT(X)
C 8002    CALL GETDAT ('Number of rows in the image:', X, 1)
C         IF (X .LT. 0.5) GO TO 8002
C         NROW = NINT(X)
C      END IF
C
C      IF (NL .GT. 0) THEN
C 8003    CALL GETDAT ('Readout noise (ADU):', READNS, 1)
C         IF (READNS .LE. 0.) GO TO 8003
C 8006    CALL GETDAT ('Gain (photons per ADU):', PHPADU, 1)
C         IF (PHPADU .LE. 0.) GO TO 8006
C 8010    CALL GETDAT ('Lowest good data-value:', LOBAD, 1)
C         IF (LOBAD .LE. -1.E38) GO TO 8010
C 8020    CALL GETDAT ('Highest good data-value:', HIBAD, 1)
C         IF (HIBAD .LE. -1.E38) GO TO 8020
C      END IF
      NL=0
c      PRINT *,' Error: Bad format file header. Return.'
      RETURN
C
      END!
C
C#######################################################################
C
      SUBROUTINE  WRHEAD (LUN, NL, NCOL, NROW, ITEMS, LOBAD, HIBAD,
     .     THRESH, AP1, PHPADU, READNS, FRAD)
C
C=======================================================================
C
C Subroutine to write a standard header into an output sequential
C data file on the disk.  Same as RDHEAD, except that all the output
C arguments are now input arguments.  ITEMS tells how many of the
C individual arguments are to be written into the header.
C
C              Latest DAOPHOT II version:  1991 January 15
C=======================================================================
C
      IMPLICIT NONE
      CHARACTER*8 HEAD(7)
      DOUBLE PRECISION A(7)
C
      DOUBLE PRECISION 
     .  LOBAD, HIBAD, THRESH, AP1, PHPADU, READNS, FRAD
      INTEGER LUN, NL, NCOL, NROW, ITEMS, I
      DATA HEAD /'  LOWBAD', ' HIGHBAD', '  THRESH', '     AP1',
     .     '  PH/ADU', '  RNOISE', '    FRAD'/
C
C-----------------------------------------------------------------------
C
      A(1)=LOBAD
      A(2)=HIBAD
      A(3)=THRESH
      A(4)=AP1
      A(5)=PHPADU
      A(6)=READNS
      A(7)=FRAD
      WRITE (LUN,900) (HEAD(I), I=1,ITEMS)
  900 FORMAT (' NL   NX   NY', 8A8)
      WRITE (LUN,901) NL, NCOL, NROW, (A(I), I=1,ITEMS)
  901 FORMAT (1X, I2, 2I5, 2F8.1, 5F8.2)
      WRITE (LUN,901)                             ! Write a blank line
      RETURN                                        ! Normal return
C
      END!
C
C#######################################################################
C
      SUBROUTINE RDCHAR (LUN, LINE, N, ISTAT)
      IMPLICIT NONE
      CHARACTER*(*) LINE
      INTEGER LUN, N, ISTAT, I, J
C
      READ (LUN,1,END=8000,ERR=9000) LINE
    1 FORMAT (A)
      N = 0
      DO I=1,LEN(LINE)
         J = ICHAR(LINE(I:I))
         IF ((J .GE. 33) .AND. (J .LE. 126)) N = I
      END DO
      ISTAT = 0
      RETURN
 8000 LINE = ' '
      N = 0
      ISTAT = 1  ! ISTAT = 1 means END OF FILE
      RETURN
 9000 LINE = ' '
      N = 0
      ISTAT = -1  ! ISTAT = -1 means ERROR
      RETURN
      END!
C
C#######################################################################
C
      SUBROUTINE  STUPID (MESSAG)
      IMPLICIT NONE
      CHARACTER*(*) MESSAG
C      CHARACTER*1 BELL
C      BELL = CHAR(7)
C      WRITE (6,601) MESSAG, BELL
C  601 FORMAT (/1X, A, A1/)
C      RETURN
      PRINT *,MESSAG  
      END!
C
C#######################################################################
